home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Mac100% 1998 November
/
MAC100-1998-11.ISO.7z
/
MAC100-1998-11.ISO
/
オンラインソフト定点観測
/
ユーティリティ
/
Mops 3.2.sea
/
Mops 3.2
/
Mops source
/
PPC source
/
cg4
< prev
next >
Wrap
Text File
|
1998-06-11
|
16KB
|
719 lines
marker m__cg4
(* =========================================================
PEF file generation
=========================================================
This file handles the writing out of a PEF object file for our compiled
PPC code.
*)
PPC?
[IF]
endload
[THEN] ¥ in PPC mode we load this code in the zPEF file. This
¥ way, objects get their classinit: etc, and things are
¥ generally less complicated.
0 constant _Z
: NULLOSSTR ['] _z ;
0 value CONTAINER_OFFS
0 value CODE_SIZE
0 value CODE_OFFS
0 value DATA_SIZE
0 value DATA_OFFS
0 value LDR_SIZE
0 value LDR_OFFS
64 constant INFO_BLOCK_SIZE ¥ a block of useful info we put at the
¥ start of the code section so our PPC
¥ code can pick it up easily.
¥ ============= resource stuff ===============
¥ (mainly lifted from InstlMod.txt)
syscall ResError
syscall ChangedResource
syscall AddResource
: CHK
ResError ?dup
IF 3 beep 3 beep
cr ." Res error# " . cr QUIT
THEN ;
¥ Class RES+ adds methods to Resource to allow various modifications
¥ to resources. We'll put more in as we need them.
:class RES+ super{ resource }
objPtr TEMPRES class_is res+
:m CHANGED: get: self ChangedResource ;m
:m ADDRES: { s255 -- }
get: self
get: resType get: ID
s255 AddResource chk ;m
;class
res+ srcres
res+ dstres
: COPYRES ¥ ( type resID -- ) Copies the resource by copying
¥ the handle's data in memory. Use this one for resources
¥ currently in use.
2dup set: srcRes set: dstRes
getnew: srcRes chk srcRes ->: dstRes
nullOSstr addRes: dstRes chk ;
¥ ===============================================================
:class SECTION_HEADER super{ object }
record
{ var sectionName
var sectionAddress
var execSize
var initSize
var rawSize
var containerOffset
ubyte regionKind
ubyte alignment
ubyte shareKind
ubyte reserved
}
:m CLASSINIT:
-1 put: sectionName ;m ¥ means no name
:m >SIZE:
dup put: execSize dup put: initSize put: rawSize
get: regionKind 4 = ¥ loader section?
IF clear: execSize
clear: initSize
THEN
;m
:m >KIND: { kind -- }
kind put: regionKind
kind 1 = kind 2 = or
IF ¥ data or PIdata
1 ¥ contextShare
ELSE 4 ¥ globalShare
THEN
put: shareKind
4 put: alignment
;m
:m >OFFSET: put: containerOffset ;m
:m INIT: ¥ ( offset size -- )
>size: self put: containerOffset ;m
;class
¥ ================== loader section stuff ===================
:class LOADER_HEADER_CLASS super{ object }
record
{ var entryPointSection
var entryPointOffset
var initPointSection
var initPointOffset
var termPointSection
var termPointOffset
var numImportFiles
var numImportSyms
var numSections ¥ number of relocation headers
var relocationsOffset
var stringsOffset
var hashSlotTable
var hashSlotTabSize
var numExportSyms
}
:m INIT: { relocTblOffs stringsOffs hashSlotTblOffs entrySect #imports -- }
relocTblOffs put: relocationsOffset
stringsOffs put: stringsOffset
hashSlotTblOffs put: hashSlotTable
entrySect put: entryPointSection
#imports put: numImportSyms
#imports 4* ¥ offset to just after imported symbols in the
¥ TOC - this will be the entry funct descriptor
put: entryPointOffset
;m
:m CLASSINIT:
1 put: entryPointSection ¥ need to use -1 for library PEFs
-1 put: initPointSection
-1 put: termPointSection
1 put: numImportFiles ¥ should only be 1 ("InterfaceLib") for
¥ Mops PEFs
1 put: numSections ¥ Only 1 loader relocation header
;m
;class
:class IMP_FILES_SUBSEC_CLASS super{ object }
record
{ var fileName
var oldDefVersion
var currentVersion
var numImports
var impFirst
ubyte initBefore
ubyte reservedB
uint reservedH
}
:m >numImports: put: numImports ;m
;class
:class PEF_HEADER_CLASS super{ object }
record
{ var joy
var fileTypeID
var architectureID
var versionNumber
var dateTimeStamp
var definVersion
var implVersion
var currentVersion
uint numberSections
uint loadableSections
var memoryAddress
}
:m CLASSINIT:
'type Joy! put: joy
'type peff put: fileTypeID
'type pwpc put: architectureID
1 put: versionNumber
3 put: numberSections
2 put: loadableSections
;m
:m SETTIMESTAMP:
¥ $ 20C @ ¥ ### fix after I can handle fetch from a
¥ literal address!
0 put: dateTimeStamp ;m
;class
:class cfrg_ClASS super{ object }
record
{ var res0
var res1
var cfrgVersion
var res2
var res3
var res4
var res5
var #fragDescs
¥ now the (only) fragment description:
var CodeType
var UpdateLevel
var CurrentVersion
var OldestDevVersion
var AppStackSize
uint AppLibDirectory
ubyte TypeOfFragment
ubyte LocationOfFragment
var OffsetToFragment
var LengthOfFragment
var res6
var res7
}
:m CLASSINIT:
1 put: cfrgVersion
1 put: #fragDescs
'type pwpc put: codeType
1 put: TypeOfFragment
1 put: LocationOfFragment
¥ everything else except LenOfInfoRec stays zero.
;m
;class
¥ PPC?
¥ [IF]
¥
¥ endload ¥ let's get files working first!
¥
¥ [THEN]
cfrg_class my_cfrg
PEF_header_class PEF_header
section_header CODE_SECT_HDR
section_header DATA_SECT_HDR
section_header LOADER_SECT_HDR
loader_header_class LOADER_HEADER
¥ we only have one import file - for more, we'd need to have more
¥ than one imp_files_subsec_class object. But note, there's only
¥ one import symbol table per PEF.
imp_files_subsec_class IMPORT_FILES_SUBSECTION
bytestring LDR_IMPORT_SYM_TBL
bytestring RELOCS
bytestring LOADER_STRINGS
bytestring $cfrg
bytestring $threads
file OUTPF
: CREATE_OUTPF? ¥ ( -- b )
clear: outpf
" PMops" name: outpf
open: outpf NIF close: outpf drop delete: outpf drop THEN
create: outpf OK?
'type APPL 'type Mopp set: outpf
$ 21 addr: outpf $ 28 + c! ¥ Set Bundle bit
setFileInfo: outpf OK?
true ;
variable PAD_BYTES
16 PPC? [IF] reservex +echox [ELSE] reserve [THEN] ¥ ensure we pad with zeros
¥ 16 reserve
: ALIGN_IN_CONTAINER { alignment# ¥ pad# -- }
alignment# container_offs alignment# 1- and -
alignment# 1- and -> pad#
pad# 0EXIT
pad_bytes pad# write: outpf OK?
pad# ++> container_offs
;
: WRITE_TO_CONTAINER { addr len ¥ pad# -- }
4 align_in_container
addr len write: outpf OK?
len ++> container_offs
;
: WRITE_OBJ { ^obj ¥ len -- }
length: [ ^obj ] -> len
^obj len write_to_container
;
0 value IMP_SYM_CNT
: ADD_IMPORT_SYMBOL ¥ ( addr len -- ) symbol name is passed in.
pos: loader_strings
$ 02000000 or ¥ means it's in the code section
+L: ldr_import_sym_tbl
add: loader_strings 0 +: loader_strings
1 ++> imp_sym_cnt ;
23 constant #IMPORTED_SYMBOLS
¥ We define this as a constant since we need it at
¥ compile time. In init_import_sym_tbl below, called
¥ at write_PEF time, we check that the real number of
¥ imported symbols agrees, and bail out if it doesn't.
¥ That avoids nasty crashes.
¥ Note the symbols we list here are CASE-SENSITIVE!! The PEF will fail at startup
¥ time if something doesn't resolve, and case matters!
: INIT_IMPORT_SYM_TBL
0 -> imp_sym_cnt
" InterfaceLib" add: loader_strings 0 +: loader_strings
" GetSharedLibrary" add_import_symbol
" FindSymbol" add_import_symbol
" Debugger" add_import_symbol
" NewHandleClear" add_import_symbol
" NewPtrClear" add_import_symbol
" MoveHHi" add_import_symbol
" HLock" add_import_symbol
" MakeDataExecutable" add_import_symbol
" BlockMove" add_import_symbol
" ExitToShell" add_import_symbol
" InitGraf" add_import_symbol
" InitFonts" add_import_symbol
" InitWindows" add_import_symbol
" TEInit" add_import_symbol
" InitMenus" add_import_symbol
" InitCursor" add_import_symbol
" AEInstallEventHandler" add_import_symbol
" GetNewWindow" add_import_symbol
" SetPort" add_import_symbol
" NewRgn" add_import_symbol
" TextMode" add_import_symbol
" SysBeep" add_import_symbol
" MaxApplZone" add_import_symbol
¥ add any more we need here.
imp_sym_cnt #imported_symbols <> abort" wrong number of imported symbols"
#imported_symbols >numImports: import_files_subsection
;
#imported_symbols 4*
constant ENTRY_POINT_TOC_OFFSET
¥ our entry point func descriptor comes straight after
¥ the imported symbols, which are 4 bytes each
: TOC_SIZE ¥ ( -- n ) 4 bytes for each imported symbol, plus 12 for
¥ our entry point function descriptor
entry_point_toc_offset 12 +
;
¥ Here we define some words so we can easily make a call to one of these
¥ symbols. We do it here so we can be sure that the TOC offsets are
¥ right - these are determined by the above order.
forward (TOC_CALL)
0 value curr_TOC_offset
: TOC_CALL
curr_TOC_offset postpone literal postpone (TOC_call)
4 ++> curr_TOC_offset ; immediate
: %_GetSharedLibrary
6 1 TOC_call ; immediate
: %_FindSymbol
4 1 TOC_call ; immediate
¥ there's no %_Debugger - we don't want regs monkeyed with when we call it!
12 -> curr_TOC_offset ¥ leave room for entry point function descriptor
: %_NewHandleClear
1 1 TOC_call ; immediate
: %_NewPtrClear
1 1 TOC_call ; immediate
: %_MoveHHi
1 0 TOC_call ; immediate
: %_HLock
1 0 TOC_call ; immediate
: %_MakeDataExecutable
2 0 TOC_call ; immediate
: %_BlockMove
3 0 TOC_call ; immediate
: %_ExitToShell
0 0 TOC_call ; immediate
: %_InitGraf
1 0 TOC_call ; immediate
: %_InitFonts
0 0 TOC_call ; immediate
: %_InitWindows
0 0 TOC_call ; immediate
: %_TeInit
0 0 TOC_call ; immediate
: %_InitMenus
0 0 TOC_call ; immediate
: %_InitCursor
0 0 TOC_call ; immediate
: %_AEInstallEventHandler
5 1 TOC_call ; immediate
: %_GetNewWindow
3 1 TOC_call ; immediate
: %_SetPort
1 0 TOC_call ; immediate
: %_NewRgn
0 1 TOC_call ; immediate
: %_TextMode
1 0 TOC_call ; immediate
: %_SysBeep
1 0 TOC_call ; immediate
: %_MaxApplZone
0 0 TOC_call ; immediate
: INIT_RELOCS
$ 00010000 +L: relocs ¥ sect 1 relocs
2 +L: relocs ¥ 2 of them - is this right??
0 +L: relocs ¥ relocs offs = 0
$ 4A00 #imported_symbols 1- or
+W: relocs ¥ SYMR n - TOC entries for our n imported symbols
$ 4600 +W: relocs ¥ DSC2 1 - maybe should be DATA 1? check.
¥ This should be for the entry funct descriptor
;
(* INIT_CODE_SECTION initializes the code section. code_start and code_size
are already set up. We just have to initialize the extra info block. We
can put whatever we need in this block. It starts straight after the initial
branch, at code_start + 4. Its size is given by the constant info_block_size ,
so if we add extra fields, remember to adjust the constant. It gets
used by GO to allot the space at the beginning of the code section before
PPC compilation starts.
Here's the format of the info block - note that this MUST AGREE with
what setup expects!
4 bytes code size
4 bytes data size
4 bytes displacement from code_start to nuc_code_start
(i.e. code generator code size)
4 bytes displacement from data_start to nuc_data_start
(i.e. code generator data size)
32 bytes initial CONTEXT
4 bytes flags - always zero (default) in target compilation
12 bytes spare
Total: 64 bytes.
*)
variable dummy_len
: FIX_THREAD { thread# ¥ thread_addr lfa -- }
thread# dummy_len c! ¥ fake a "length byte" for THREAD
dummy_len thread -> thread_addr ¥ addr of thread start in CONTEXT
thread_addr displace -> lfa ¥ addr of first link field in thread,
¥ in CONTEXT
lfa
code_start 20 + thread# 4* +
displ! ¥ store in new CONTEXT
BEGIN
lfa displace ¥ chain back
dup code_start u<
IF drop ¥ next link field is below start of code
¥ - save orig, then kill link
lfa @ +L: $threads lfa +L: $threads
0 lfa ! EXIT
THEN
-> lfa
AGAIN
;
: ADD_CONTEXT
new: $threads ¥ init string to save orig threads
#threads FOR i fix_thread NEXT
;
: RESTORE_THREADS
reset: $threads
BEGIN len: $threads
WHILE nxtL: $threads ( orig link ) nxtL: $threads ( where it went ) !
REPEAT
release: $threads
;
: INIT_CODE_SECTION
code_size code_start 4 + ! ¥ code size
data_size code_start 8 + ! ¥ data size
nuc_code_start code_start -
code_start 12 + ! ¥ displ to nuc_code_start
nuc_data_start data_start -
code_start 16 + ! ¥ offset to last extern
add_context ¥ adds 32 bytes
;
: INIT_DATA_SECTION
; ¥ data_start and data_size are set up already
: INIT_LOADER_SECTION
init_import_sym_tbl
init_relocs
;
: SET_OFFSETS { ¥ relocsOffs stringsOffs hashSlotTblOffs -- }
0 -> container_offs
$ 80 -> ldr_offs
length: loader_header
#align4 length: import_files_subsection +
#align4 size: ldr_import_sym_tbl +
#align4 12 + ¥ reloc header is always 12 bytes
dup -> relocsOffs
size: relocs 12 - + ¥ we've counted the reloc header already
#align4 dup -> stringsOffs
size: loader_strings +
#align4 dup -> hashSlotTblOffs
-> ldr_size
relocsOffs stringsOffs hashSlotTblOffs
1 ( data section )
#imported_symbols
init: loader_header
ldr_offs ldr_size + #align16 -> code_offs
code_offs code_size + #align16 -> data_offs
0 >kind: code_sect_hdr
1 >kind: data_sect_hdr
4 >kind: loader_sect_hdr
code_offs code_size init: code_sect_hdr
data_offs data_size init: data_sect_hdr
ldr_offs ldr_size init: loader_sect_hdr
;
res+ srcres
res+ dstres
syscall CreateResFile
syscall OpenResFile
syscall CloseResFile
: add_resources { ¥ refNo -- }
¥ First we add the 'cfrg' resource:
getName: outpf str255
CreateResFile chk
buf255 OpenResFile -> refNo chk
new: $cfrg
my_cfrg length: my_cfrg add: $cfrg
size: $cfrg getName: outpf nip + $ 1D - ¥ len of info record section
+W: $cfrg
getName: outpf dup +c: $cfrg add: $cfrg
$cfrg @ dstres ! ¥ both are subclassed from Handle!
'type cfrg 0 set: dstres
nullOSstr addRes: dstres chk
'type WIND 256 copyRes ¥ copy fWind (WIND 256)
'type BNDL 129 copyRes ¥ and the BNDL
133 128 DO ¥ and the FREFs, icl8's and ICN#s
'type FREF i copyRes ¥ (128 - 132)
'type icl8 i copyRes
'type ICN# i copyRes
LOOP
'type ics8 128 copyRes ¥ and ics8 128
'type SIZE -1 copyRes ¥ and SIZE -1
¥ Now we create the new version resource which has a "type" that is the
¥ same as the sig, and ID 0.
'type Mopp 0 set: dstRes
" interim" dup 1+ align new: dstRes
str255 ptr: dstRes over c@ 1+ cMove
nullOSstr addRes: dstRes
refNo CloseResFile ;
¥ note we mustn't release: $cfrg since the handle now belongs to the
¥ Resource Manager!
: WRITE_PEF
create_outpf? 0EXIT
code_limit code_start - -> code_size
data_limit data_start - -> data_size
cr
." code size (hex): " code_size .h cr
." data size (hex): " data_size .h cr
init_code_section
init_data_section
init_loader_section
set_offsets
setTimeStamp: PEF_header
¥ write PEF header:
PEF_header write_obj
code_sect_hdr write_obj
data_sect_hdr write_obj
loader_sect_hdr write_obj
pad_bytes 4 write_to_container ¥ dummy global symbol table
¥ loader section:
loader_header write_obj
import_files_subsection write_obj
all: ldr_import_sym_tbl write_to_container
all: relocs write_to_container
all: loader_strings write_to_container
¥ code section:
16 align_in_container
code_start code_size write_to_container
¥ data section:
16 align_in_container
data_start data_size write_to_container
release: ldr_import_sym_tbl
release: relocs
release: loader_strings
close: outpf drop
add_resources
restore_threads
;
:f I/O_err
." I/O err " . cr
close: outpf drop
;f